package Stdlog::Formatter;

require 5.008;
use strict;
use warnings;
use POSIX qw(strftime);

our $tmsp_fmt = '%Y-%m-%d %H:%M:%S';
our $date_fmt = '%Y-%m-%d';
our $time_fmt = '%H:%M:%S';

our %fmt_dirs = (
    'datetime'  => \sub{ my $o=shift; q[sf_ltime('].($o||$tmsp_fmt).q[', $args->{time})] },
    'date'      => \sub{ my $o=shift; q[sf_ltime('].($o||$date_fmt).q[', $args->{time})] },
    'time'      => \sub{ my $o=shift; q[sf_ltime('].($o||$time_fmt).q[', $args->{time})] },
    'timestamp' => \sub{ my $o=shift; q[sf_gtime('].($o||$tmsp_fmt).q[', $args->{time})] },
    'gmdate'    => \sub{ my $o=shift; q[sf_gtime('].($o||$date_fmt).q[', $args->{time})] },
    'gmtime'    => \sub{ my $o=shift; q[sf_gtime('].($o||$time_fmt).q[', $args->{time})] },
    'severity'  => '$args->{severity}',
    'message'   => '@_',
    'env'       => '$ENV{__OPTS__}',
    'opt'       => '$args->{opt}{__OPTS__}',
    'facility'  => '$0',
    'host'      => sub{ Sys::Hostname::hostname(); },
    'pid'       => '$$',
    'tid'       => 'threads->tid',
    'uid'       => '$<',
    'euid'      => '$>',
    'gid'       => '$(',
    'egid'      => '$)',
    'osname'    => '$^O',
    'errno'     => '$!',
    'exception' => '$@',
    'package'   => '$args->{package}',
    'filename'  => '$args->{filename}',
    'line'      => '$args->{line}',
    'var'       => '__OPTS__',
    'expr'      => '__OPTS__',
);


# Hack to speed up the calls to strftime by memoizing a single result for each
# format string.  This prevents us from having to call strftime() repeatedly
# for the same time value.  Given that the time value changes monotonically,
# there is no need to memoize more than one per format.
{
    my %last_args = ();      # keys are format strings, values are epoch times
    my %last_results = ();   # last formatted timestamps

    # Takes strftime format and UNIX epoch time as arguments and returns the
    # formatted local timestamp string
    sub sf_ltime {
        unless(exists $last_args{$_[0]} && $last_args{$_[0]} == $_[1]){
            $last_args{$_[0]} = $_[1];
            $last_results{$_[0]} = strftime($_[0], localtime($_[1]));
        }
        return $last_results{$_[0]};
    }
}

# Same hack as above, but for gmtime
{
    my %last_args = ();      # keys are format strings, values are epoch times
    my %last_results = ();   # last formatted timestamps

    # Takes strftime format and UNIX epoch time as arguments and returns the
    # formatted gmt timestamp string
    sub sf_gtime {
        unless(exists $last_args{$_[0]} && $last_args{$_[0]} == $_[1]){
            $last_args{$_[0]} = $_[1];
            $last_results{$_[0]} = strftime($_[0], gmtime($_[1]));
        }
        return $last_results{$_[0]};
    }
}


# Creates a function based on the format string.  As it scans the format
# string with a regex, looking for directives, each component is pushed onto
# a stack (@tokens).
sub new {
    my ($pkg, $conf) = @_;
    
    my $fmt = (ref $conf ? $conf->{format} : $conf) || "%{message}";
    my $parts = parse_format_str($fmt);
    my $self  = gen_format_sub($parts);
    die "Error in format string ($@)\n" unless ref($self) eq 'CODE';
    bless $self, $pkg;
    return $self;
}


sub gen_format_sub {
    my $parts = shift;
    # now generate the sub code as a string, eval and return it
    my $code = 'sub{ my $args=shift; ';
    $code .= q[join('',] . join(',', map {"($_)"} @$parts) . ');';
    $code .= "}";
    return eval $code;
}


# Parse a format string that may include %{opts:name} directives and return
# an array (or arrayref in scalar context) of tokens.  Each token is either a
# scalar or a coderef.  The 
sub parse_format_str {
    local $_ = shift;
    my $fmts = '';
    my @tokens;
    
    s/\\/\\\\/g;   # escape backslashes
    while( s/(.*?)%{(?:([^:]*?):)?(\w+)}// ){
        push @tokens, qq("$1") if length($1);
        my ($fmt, $opts) = defined $3 ? ($3, $2||'') : ($2, '');
        unless(exists $fmt_dirs{$fmt}){
            die "Unknown directive '$fmt' in Stdlog format\n";
        }
        my $dir = $fmt_dirs{$fmt};
        if( my $rtype = ref $dir ){
            if( $rtype eq 'CODE' ){
                $opts =~ s/'/\\'/g;
                push @tokens, "\$Stdlog::Formatter::fmt_dirs{$fmt}->(\$args, '$opts')";
            }elsif( $rtype eq 'REF' && ref($$dir) eq 'CODE' ){
                # $dir is a ref to a coderef
                push @tokens, $$dir->($opts);
            }else{
                die "Unexpected reference ($fmt) in formatting directive!\n";
            }
        }else{
            my $s = $fmt_dirs{$fmt};
            $s =~ s/__OPTS__/$opts/e;
            push @tokens, $s;
        }
    }
    # push the last part
    push @tokens, qq("$_") if length($_);
    return wantarray ? @tokens : \@tokens;
}


1;
__END__

=head1 NAME

Stdlog::Formatter -- functions to formatted log output

=head1 SYNOPSIS

  use Stdlog::Formatter;
  
=head1 DESCRIPTION

Formatter objects

=head2 Formatting Directives

Formatting directives take the form %{OPTS:NAME} where the OPTS: is optional.
For exmple, the default logging format is:

    %{timestamp} %{severity} %{message}

A large number of built-in formatting directives are available:

=over 4

=item %{timestamp}

Shortcut to output the ISO-8601 formatted local date/time with timezone.  The
equivalent strftime format is "%y-%m-%d %H:%M:%S %z" and will always be 25
characters long.

=item %{FMT:date}

The localtime date with an optional FMT as used by strftime.  The default FMT
is %y-%d-%m.

=item %{FMT:gmdate}

The same as ${date} but uses the GMT time instead of local time.

=item %{FMT:time}

The localtime time with an optional FMT as used by strftime.  The default FMT
is %H:%M:%S.

=item %{FMT:gmtime}

The same as ${time} but uses the GMT time instead of local time.

=item %{severity}

The severity of the log message (FATAL through DEBUG)

=item %{message}

The messages passed to the logging function joined together.

=item %{facility}

The name of the process (generally fetched from $0).

=item %{FOO:env}

The contents of an environment variable FOO, as in $ENV{FOO}.

=item %{host}

The hostname of the machine the process is running on.

=item %{pid}

The process id.

=item %{tid}

The thread id (if threads are enabled).

=item %{package}

The name of the package the logging function was called from.

=item %{filename}

The name of the file the logging function was called from.

=item %{line}

The line of code the logging function was called from.

=back

You can reference any global variables by simply using them in the format
string.  They will be evaluated (interpolated?) at logging time.

For example:

=over 4

=item $ENV{FOO}

=item $$

The process id

=item $0

The program name (aka facility)

=item $!

=back

=head2 Adding Your Own Directives

You can add your own formatting directives by calling the class method
add_directive.

=head1 CLASS METHODS

=head2 Stdlog::Formatter->new

Creates and returns a Stdlog::Formatter object.  Note, the object is a
blessed coderef, NOT a typical blessed hashref.

=head2 Stdlog::Formatter->add_directive(NAME, SUB)

Adds a directive named NAME that should call SUB to determine the value to
log.

=head1 OBJECT METHODS

None, call the object directly (i.e. $formatter->(@args))

=head1 EXPORTS

Nothing.

=head1 SEE ALSO

L<Stdlog>, L<Stdlog::Writer>

=head1 AUTHOR

Robert Mah E<lt>rmah@pobox.comE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Robert Mah

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut
